The Original Shareware 1.1/The Original Shareware (WeMake CDs)(Volume 1.1)(CDs, Inc)(1993).iso/19/madtrb14.zip/TURBUTIL.PAS

Pascal/Delphi Source File | 1985-06-22 | 54KB | 1,664 lines

{***************************************************************************
*                                                                          *
*  Util.Pas                                                                *
*    This source file by Jim Nutt                                          *
*        CIS 76044,1155                                                    *
*        CIS 71076,1434                                                    *
*        FIDO Jim Nutt @ #452                                              *
*                                                                          *
*    First Uploaded to DL1 of the Borland SIG on CIS November 30, 1984     *
*    This revision 05/24/85                                                *
*    When you get this file please notify me at FIDO #452, I am going to   *
*    attempt to track its distribution.  Thank you, Jim Nutt               *
*                                                                          *
*  This Module Comprises the various utility routines used by the other    *
* modules in the program.  Routines included in this module are:           *
*                                                                          *
*         Routine                   Use                                    *
*  *  1   Upper_Left_X      Returns the left x coordinate of active window *
*  *  2   Upper_Left_Y      Returns the upper y coord of active window     *
*  *  3   Lower_Right_X     Returns the right x coord of active window     *
*  *  4   Lower_Right_Y     Returns the lower y coord of active window     *
*  *  5   RvsOn             Turns on Reverse Video                         *
*  *  6   RvsOff            Turns off Reverse Video                        *
*     7   Yes               Prints a prompt, if user inputs 'Y' returns    *
*                           Trues, otherwise returns False                 *
*  *  8   Click             Produces a single click from the PC speaker    *
*  *  9   Alert             Prints a message to the screen and makes noise *
*  * 10   Beep              Makes noise for a specified period of time     *
*    11   Replicate         Duplicates a character a specified no. of times*
*    12   Left              Left justifys a string in a field of spaces    *
*    13   Center            Centers a string in a field of specified width *
*    14   Get_Payment_Amount Calculates a loan payment amount              *
*    15   Write_Neatly      Outputs numbers with commas                    *
*    16   Get_Str           Writes a string to the screen, allows it to be *
*                           edited and returns the terminating character   *
*    17   Get_Num           Does for numbers what Get_Str does for strings *
*  * 18   Frame             Frames a specified portion of the screen       *
*  * 19   UnFrame           Removes the frame from the screen              *
*  * 20   Menu              Displays a menu and gets a user input          *
*  * 21   Clear_Window      Clears the screen within a window              *
*  * 22   Window_Frame      Sets up, frames and titles a screen window     *
*  * 28   Push_Screen       Saves the current screen                       *
*  * 29   Pop_Screen        Restores a saved screen                        *
*    30   Inc               Increments an integer by 1                     *
*    31   Dec               Decrements an integer by 1                     *
*    34   Upper             Convert String to Upper Case                   *
*    35   Lower             Convert String to Lower Case                   *
*    39   Power             Raises a number to a power                     *
*  * 43   Marquee           Display Marquee and put message in it          *
*  * 44   Help              Displays an appropriate help screen            *
*  * 48   GetForm           generalized input routine                      *
*  * 49   Date              gets the date from the system                  *
*  * 50   Time              gets time from system                          *
*  * 51   Push_Window       pushes a small section of the screen           *
*                                                                          *
*  * Indicates that the routine has IBM PC specific sections and would need*
*    to be modified for other computers                                    *
****************************************************************************}

procedure color(fc,bc : byte);

begin
  textcolor(fc);
  textbackground(bc);
end;

procedure highvideo;

begin
  textcolor(white);
  textbackground(back_ground_color);
end;

procedure normvideo;

begin
  textcolor(white);
  textbackground(back_ground_color);
end;

procedure lowvideo;

begin
  textcolor(lightgray);
  textbackground(back_ground_color);
end;

{****************************************************************************}

function upper_left_x : integer;       {* These four routines allow a       *}
{1*}                                   {* routine to adjust its output      *}
begin                                  {* according to what size window it  *}
  upper_left_x := mem[dseg:$4] + 1;    {* is operating in.  They are        *}
end;                                   {* compatible only with Turbo Pascal *}
                                       {* version 3 on an IBM PC or         *}
function upper_left_y : integer;       {* compatible                        *}
{2*}
begin
  upper_left_y := mem[dseg:$5] + 1;
end;

var
{3*}
  lower_right_x : byte absolute cseg: $16a;
{4*}
  lower_right_y : byte absolute cseg: $16b;

{****************************************************************************}

procedure rvson;                       {*  These two routines turn on and   *}
{5*}                                   {*  off Reverse video on the IBM PC  *}
begin                                  {*************************************}
  textcolor(0);
  textbackground(7);
end;

procedure rvsoff;
{6*}
begin
  normvideo;
end;

{30**************************************************************************}

procedure inc(                     {* Increment argument by One             *}
              var i : integer);        {*****************************************}

begin
  i := i + 1;
end;

{31**************************************************************************}

procedure dec(                     {* Decrement argument by One             *}
              var i : integer);        {*****************************************}

begin
  i := i - 1;
end;

{26**************************************************************************}

procedure wait;                       {* Wait for a keypress from the KBD   *}
{**************************************}

var
  anykey : char;

begin
  read(kbd,anykey);
end;

{****************************************************************************}

type                                 {* Just a couple(?) of type declarations*}
  menu_item       = string[40];      {* needed for a number of routines   *}
{*************************************}
  menu_selections = array[1..30] of menu_item;
  long_string     = string[255];
  register        = record
                      ax,bx,cx,dx,bp,si,di,ds,es,flags : integer;
                    end;
  screenloc       = record
                      ch            : char;
                      attrib        : byte;
                    end;
  video           = array[1..25] of array[1..80] of screenloc;
  video_ptr       = ^video_stack;
  vidscr          = array[1..1] of screenloc;
  charset         = set of char;
  video_stack     = record
                      next_screen  : video_ptr;
                      x1,y1,
                      x2,y2        : byte;
                      screen_store : ^vidscr;
                    end;

var
  screenbuffer  : video;
  screen_stack  : video_ptr;
  screen        : ^video;
  com           : integer;
  helpcontext   : integer;
  screenfile    : file of video;

  const
    valid_set     : charset = [' '..'~'];
    digits        : charset = ['0'..'9'];
    letters       : charset = ['A'..'Z','a'..'z'];
    uppercase     : charset = [' '..'`','{'..'~'];
    lowercase     : charset = [' '..'@','['..'~'];
    numbers       : charset = ['0'..'9','e','E','+','-','.',','];
    allchars      : charset = [' '..'~'];

{7***************************************************************************}

function yes(prompt : long_string) : boolean;{* This routine prints PROMPT  *}
                                             {* to the screen and waits for *}
var                                          {* the user to type either a   *}
  inchar : char;                             {* 'y' or 'n'.  It is case     *}
                                             {* insensitive.  If a 'y' is   *}
begin                                        {* entered, the function       *}
  write(prompt);                             {* returns TRUE.               *}
  repeat                                     {*******************************}
    read(kbd,inchar);
  until inchar in ['Y','y','N','n'];
  write(inchar);
  yes := inchar in ['Y','y'];
end;

{34**************************************************************************}

function upper (s : long_string)       {* Convert Strng S to Upper case     *}
               : long_string;          {* Return uppercase string           *}
{*************************************}

var
  i : integer;
  lcase : set of char;

begin
  lcase := ['a'..'z'];

  for i := 1 to length(s) do
    if s[i] in lcase
      then
        s[i] := char(ord(s[i]) - 32);
  upper := s;
end;

{35**************************************************************************}

function lower (s : long_string)    {* Convert string S to lowercase        *}
               : long_string;       {* Return lowercase string              *}
{****************************************}

var
  i : integer;
  ucase : set of char;

begin
  ucase := ['A'..'Z'];

  for i := 1 to length(s) do
    if s[i] in ucase
      then
        s[i] := char(ord(s[i]) + 32);
  lower := s;
end;

{8***************************************************************************}

procedure click;                       {* Makes a clicking noise            *
*************************************}

var f,n : integer;

begin
  sound(2000);
  delay(5);
  nosound;
end;

{9***************************************************************************}

procedure alert(message : long_string);{* This routine prints MESSAGE to the*}
                                       {* screen and makes an obnoxious     *}
var                                    {* noise for about 1 second          *}
  i : integer;                         {*************************************}
  i1,i2,i3,i4 : integer;


begin
  write(message);
  for i4 := 1 to 10 do
    begin
      i2 := 250 + i4 * 25;
      for i3 := 1 to 2 do
        begin
          for i1 := 1 to 30 - i3 * 2 do
            begin
              sound(i1 + i2 + i3 * 2);
              delay(2);
            end;
          delay(5);
          i2 := i2 + 30;
        end;
      nosound;
    end;
end;

{21**************************************************************************}

procedure clear_window;          {* Clear the Active window                 *}
{*******************************************}

var
  i : integer;

begin
  for i := 1 to lower_right_y - upper_left_y + 1 do
    begin
      gotoxy(1,i);
      clreol;
    end;
end;

{10**************************************************************************}

procedure beep(n : integer);    {*  This routine sounds a tone of frequency *}
                                {*  N for approximately 100 ms              *}
begin                           {********************************************}
  sound(n);
  delay(100);
  nosound;
end;

{28**************************************************************************}

procedure push_screen;                {* This routine stores the current    *}
                                      {* screen into a temporary storage    *}
                                      {* area                               *}
                                      {**************************************}

var
  temp   : video_ptr;
  i,j,k  : integer;

begin
  if (maxavail < 0) or (maxavail > 4096)
    then
      begin
        if screen = nil
          then
            screen := ptr($b000,0);
        new(temp);
        temp^.x1 := 1;
        temp^.y1 := 1;
        temp^.x2 := 80;
        temp^.y2 := 25;
        getmem(temp^.screen_store,4000);
        temp^.next_screen := screen_stack;
        k := 1;
        for i := 1 to 25 do
          for j := 1 to 80 do
            begin
              temp^.screen_store^[k] := screen^[i][j];
              inc(k);
            end;
        screen_stack := temp;
      end
    else
      begin
        alert('Insufficient Memory - You are being dumped');
        halt;
      end;
end;

{29**************************************************************************}

procedure pop_screen;                 {* This routine Pops a screen from the*}
                                      {* Screen Stack                       *}
                                      {**************************************}

var
  temp   : video_ptr;
  i,j,k  : integer;

begin
  if screen = nil
    then
      screen := ptr($b000,0);

  k := 1;
  for i := screen_stack^.y1 to screen_stack^.y2 do
    for j := screen_stack^.x1 to screen_stack^.x2 do
      begin
        screen^[i][j] := screen_stack^.screen_store^[k];
        inc(k);
      end;

  temp := screen_stack;
  screen_stack := screen_stack^.next_screen;
  freemem(temp^.screen_store,
          ((temp^.x2 - temp^.x1 + 1) * (temp^.y2 - temp^.y1 + 1)) * 2);
  dispose(temp);
end;

{43**************************************************************************}

procedure marquee                    {* Draws a marquee in center screen    *}
                 (str : long_string);{* Around the input parameter          *}
                                     {***************************************}

const
  onchr = #1;
  offchr = #2;

var
  i,j,k : integer;
  x,y   : integer;
  astrsk : array[1..4] of record
                            x,y : integer;
                            oldx,oldy : integer;
                            xi,yi     : integer;
           end;

begin
  window(1,1,80,25);
  push_screen;
  clrscr;
  x := 40 - length(str) div 2 - 2;
  for i := 10 to 14 do
    begin
      screen^[i][x].ch := onchr;
      screen^[i][x].attrib := 7;
      screen^[i][x + length(str) + 3].ch := onchr;
      screen^[i][x + length(str) + 3].attrib := 7;
    end;
  for i := x to x + length(str) + 3 do
    begin
      screen^[10][i].ch := onchr;
      screen^[14][i].ch := onchr;
      screen^[10][i].attrib := 7;
      screen^[14][i].attrib := 7;
    end;
  gotoxy(x+2,12);
  highvideo;
  write(str);
  lowvideo;

  astrsk[1].x := 40;
  astrsk[1].y := 10;
  astrsk[1].xi := 1;
  astrsk[1].yi := 0;
  astrsk[2].x := x;
  astrsk[2].y := 12;
  astrsk[2].xi := 0;
  astrsk[2].yi := -1;
  astrsk[3].x := x + length(str) + 3;
  astrsk[3].y := 12;
  astrsk[3].xi := 0;
  astrsk[3].yi := 1;
  astrsk[4].x := 40;
  astrsk[4].y := 14;
  astrsk[4].xi := -1;
  astrsk[4].yi := 0;
  astrsk[4].oldx := astrsk[1].x;
  astrsk[4].oldy := astrsk[1].y;
  astrsk[3].oldx := astrsk[2].x;
  astrsk[3].oldy := astrsk[2].y;
  astrsk[2].oldx := astrsk[3].x;
  astrsk[2].oldy := astrsk[3].y;
  astrsk[1].oldx := astrsk[4].x;
  astrsk[1].oldy := astrsk[4].y;
  k := 1;

  repeat
    if k > 4
      then
        k := 1;

    j := astrsk[k].y;
    i := astrsk[k].x;

    if screen = ptr($b800,0)
      then
        repeat
        until (port[$3da] and 1) = 1
      else
        repeat
        until (port[$3ba] and 1) = 1;

    screen^[j][i].ch := offchr;
    screen^[astrsk[k].oldy][astrsk[k].oldx].ch := onchr;
    screen^[j][i].attrib := 15;
    screen^[astrsk[k].oldy][astrsk[k].oldx].attrib := 7;

    astrsk[k].oldx := astrsk[k].x;
    astrsk[k].oldy := astrsk[k].y;

    i := i + astrsk[k].xi;
    j := j + astrsk[k].yi;

    if i > (x + length(str) + 3)
      then
        begin
          i := i - astrsk[k].xi;
          astrsk[k].xi := 0;
          astrsk[k].yi := 1;
        end;

    if j > 14
      then
        begin
          j := j - astrsk[k].yi;
          astrsk[k].yi := 0;
          astrsk[k].xi := -1;
        end;
    if i < x
      then
        begin
          i := i - astrsk[k].xi;
          astrsk[k].xi := 0;
          astrsk[k].yi := -1;
        end;
    if j < 10
      then
        begin
          j := j - astrsk[k].yi;
          astrsk[k].yi := 0;
          astrsk[k].xi := 1;
        end;

    astrsk[k].y := j;
    astrsk[k].x := i;
    inc(k);

  until keypressed;
  wait;
  pop_screen;
end;

{44**************************************************************************}

procedure help;                      {* This routine reads a screen from the*}
                                     {* Screen file and displays it         *}
begin                                {***************************************}
  push_screen;
{$I-}
  seek(screenfile,helpcontext);
{$I+}
  if ioresult = 0
    then
      begin
{$I-}
        read(screenfile,screenbuffer);
{$I+}
        screen^ := screenbuffer;
        if ioresult <> 0
          then
            marquee('Sorry, I''m helpless in this situation')
          else
            wait;
      end
    else
      marquee('Sorry, wish I could help you.');
  pop_screen;
end;

{11**************************************************************************}

function replicate (                          {* Repeat a character         *}
                    count : integer;          {* Number of Repititions      *}
                    ascii : char              {* Character to be repeated   *}
                    )      : long_string;     {* String containing repeated *}
                                              {* character                  *
* This function takes the character in 'Ascii', repeats it 'Count' times   *
* and returns the resulting string as a 'Long_String'                      *
****************************************************************************}

var
  temp : long_string;  {Used to hold the incomplete result}
  i    : byte;         {For Counter}

begin
  temp := '';
  for i := 1 to count do
    temp := temp + ascii;
  replicate := temp;
end; {Replicate}

{12*************************************************************************}

function left (                       {* Left Justifies a string in a      *}
               str : long_string;    {* field of spaces                   *}
               width : integer       {*************************************}
) : long_string;

begin
  if length(str) > width
    then
      left := copy(str,1,width)
    else
      left := str + replicate(width - length(str),' ');
end;

{13**************************************************************************}

function center (                              {* Centers a string in field *}
                 field_width   : byte;        {* Width of field for center *}
                 center_string : long_string  {* String to Center          *}
)               : long_string; {* Return the string         *}
{************************************************                           *
* This functions takes the string 'Center_String' and centers it in a      *
* field 'Field_Width' Spaces long.  It returns a 'Long_String' with a      *
* length equal to 'Field_Width'.  If the 'Center_String' is longer than    *
* field width, it is truncated on the right end and is not centered.       *
****************************************************************************}

var
  temp   : long_string;
  middle : byte;
  num_ldg_blanks : byte;

begin
  middle := field_width div 2;
  num_ldg_blanks := middle - (length(center_string) div 2) - 1;
  if length(center_string) > field_width
    then
      center := copy(center_string,1,field_width) {Truncate and return}
    else
      begin
        temp := replicate(num_ldg_blanks,' ') +
                center_string +
                replicate(field_width - (num_ldg_blanks+length(center_string)),' ');
        center := copy(temp, 1, field_width)  {Truncate to Field_Width Characters}
      end {Else}
end; {Center}

{39*************************************************************************}

function power(x : real; y : integer):   {* This function raises X to the  *}
                                       real;
{* Yth power                      *}
{**********************************}

var
  i : integer;
  n : real;

begin
  n := 1.0;
  for i := 1 to y do
    n := n * x;
  power := n;
end; {Power}

{14*************************************************************************}

function  get_payment_amount (loan_amount :   real;
                              interest_rate : real;
                              amort_over    : real
)              : real;

var

  monthly_interest_rate   :  real;
  number_of_payments      :  integer;

begin

  monthly_interest_rate  :=  (interest_rate / 100.0) / 12.0;
  number_of_payments  := trunc (amort_over * 12);
  get_payment_amount := loan_amount *
                        (1 / ((1 - 1 / power((1 + monthly_interest_rate),
                        number_of_payments))/
                        monthly_interest_rate));

end;

{15**************************************************************************}

procedure write_neatly (                 {* Routine to write numbers        *}
                        var outfile  : text;  {* output file                     *}
                        number   : real;  {* Number to be written            *}
                        width    : byte;  {* Width of write area             *}
                        max_dec  : byte   {* Number of decimal places        *}
);                {* This routine takes NUMBER, and  *}
{* formats it with commas and      *}
{* truncates to MAX_DEC decimal    *}
{* places.  If NUMBER is to big to *}
{* fit in WIDTH, then a row of     *}
{* asterisks WIDTH long is output  *}
{***********************************}

const
  valid_digits : set of char = ['0'..'9','.','-','+','e'];

var
  field : long_string;
  point : integer;
  i,j   : integer;       {Spares for counters}

begin
  for i := 1 to max_dec do
    number := number * 10;
  number := number + 0.6;
  for i := 1 to max_dec do
    number := number / 10;
  str(number:0:20,field);  {Convert the input to a string}
  i := 1;

  i := pos('.',field);  {Where's the Decimal!}

  if i = 0
    then
      begin
        field := field + '.';     {If no decimal, then add one}
        point := length(field);
      end
    else
      point := i;

  i := point - 3;  {Get the Point?}

  while i > 1 do             {put in commas, start at the back and work }
    begin                    {to the front}
      insert(',',field,i);
      i := i - 3
    end;

  i := pos('.',field) - 1;    {Find that pesky decimal}
  j := 0;

  while j <= max_dec do
    begin
      i := i + 1;                  {Pad to Max_Dec with zeros}
      if i >= length(field)
        then
          field := field + '0';
      j := j + 1;
    end;

  field := copy(field,1,i);      {Clean it up a little and elimate trailers}

  if max_dec = 0
    then
      field := copy(field,1,i - 1); {Truncate to integer if necessary}

  if (length(field) > width) and (width > 0)
    then
      write(replicate(width,'*'))  {Too Big! tell with asterisks}
    else
      write(outfile,field:width);  {all that for this}

end;

{16**************************************************************************}

function get_str (                          {* Get a string with editing    *}
                  var in_str      : long_string; {* String to be edited          *}
                  buffer_len  : integer;     {* Its length                   *}
                  start_x     : integer;     {* Column to start in           *}
                  y           : integer;     {* Row for input                *}
                  force_case  : boolean      {* Force Input to Upper case    *}
)           : char;        {* Return terminating Character *}
{*                              *}
{* This is a fairly versatile   *}
{* string input and editing     *}
{* routine.  It takes IN_STRING *}
{* displays it at START_X,ROW   *}
{* allows the user to edit the  *}
{* string using WordStar(tm)    *}
{* commands.  It returns the    *}
{* character used to terminate  *}
{* input.  By setting FORCE_CASE*}
{* true, all input is forced to *}
{* upper case                   *}
{********************************}

const
  keyclick = true;

var
  insert_mode  : boolean;
  done         : boolean;
  current_char : char;
  x            : byte;
  escape       : boolean;
  current      : char;
  in_string    : long_string;

begin
  done         := false;        { **                              }
  insert_mode  := false;        {  * Initialize starting variables}
  gotoxy(start_x,y);            {  *                              }
  x := start_x;                 { **                              }
  write(replicate(buffer_len,'_'));
  in_string := in_str;
  gotoxy(x,y);
  write (in_string);            {Write the initial value of the string}
  gotoxy(x,y);

  repeat                                 {Start main edit/input loop}

    if (x - start_x) = buffer_len
      then
        current_char := ^m                {Terminate input if buffer is full}
      else
        read(kbd,current_char);           {Get a character}

    if (current_char = ^[) and not keypressed
      then
        begin
          in_str := in_string;
          get_str := ^[;
          exit;
        end;

    if force_case
      then
        current_char := upcase(current_char); {force case if necessary}

    repeat
      escape := false;
      case current_char of        {Act on the current input}

        ^[        : if keypressed
                      then
                        begin
                          read(kbd,current_char);
                          escape := true;
                          case current_char of           {Translate escape codes to}
                            'H' : current_char := ^e;    {WordStar command codes   }
                            'P' : current_char := ^x;
                            'K' : current_char := ^s;
                            'M' : current_char := ^d;
                            'S' : current_char := ^g;
                            'R' : current_char := ^v;
                            '<' : current_char := ^r;
                            's' : current_char := ^a;
                            't' : current_char := ^f;
                            ';' : begin
                                    help;
                                    current_char := ^@;
                                  end;
                            'D' : begin                  {Special Terminator}
                                    done := true;
                                    escape := false;
                                  end;
                            'I' : begin
                                    done := true;
                                    escape := false;
                                  end;
                            'Q' : begin
                                    done := true;
                                    escape := false;
                                  end;
                            'O' : begin
                                    done := true;
                                    escape := false;
                                  end;
                            'G' : begin
                                    done := true;
                                    escape := false;
                                  end;
                          end; {Case}
                        end; {^[}
        ^e        : done := true;                  {**               }
{ ** All finished }
        ^x        : done := true;                  {**               }
        ^f        : x := start_x + length(in_string);
        ^a        : x := start_x;
        ^r        : begin
                      in_string := in_str;
                      gotoxy(start_x,y);
                      write(replicate(buffer_len,'_'));
                      gotoxy(start_x,y);
                      write(in_string);
                    end;

        ^v        : insert_mode := insert_mode xor true; {toggle insert}

        ^s        : if x > start_x
                      then    {non destructive backspace}
                        x := x - 1;

        ^h,#127   : if x > start_x
                      then    {destructive backspace}
                        begin
                          delete(in_string, x - start_x, 1);
                          gotoxy(start_x,y);
                          write(in_string + '_');
                          x := x - 1;
                        end;

        ^d        : if (x - start_x) < buffer_len
                      then  {forward 1 character}
                        if (x - start_x) < length(in_string)
                          then
                            x := x + 1;

        ^g        : begin
                      delete(in_string, x - start_x + 1,1); {delete character}
                      gotoxy(start_x,y);                    {under the cursor}
                      write(in_string + '_');
                    end;

        ^m        : done := true;         {**}
{ *** All Done}
        ^j        : done := true;         {**}

        ' '..'~'  : if current_char in valid_set
                      then
                        if (x - start_x) >= length(in_string)
                          then
                            begin
                              in_string := in_string + current_char;
                              gotoxy(x,y);
                              write(current_char);
                              if (x - start_x) < buffer_len
                                then
                                  x := x + 1;
                            end

                          else

                            if insert_mode
                              then   {Just a run of the mill character}
                                begin               {Insert Mode}
                                  insert(current_char,in_string, x - start_x + 1);
                                  in_string := copy(in_string,1,buffer_len);
                                  gotoxy(start_x,y);
                                  write(in_string);

                                  if (x - start_x) < buffer_len
                                    then
                                      x := x + 1;
                                  gotoxy(x,y);
                                end

                              else

                                begin              {OverWrite Mode}
                                  in_string[x - start_x + 1] := current_char;
                                  gotoxy(x,y);
                                  write(current_char);
                                  if (x - start_x) < buffer_len
                                    then
                                      x := x + 1;
                                end
                      else
                        beep(1720)
      end; {Case}
    until not escape;
    gotoxy(x,y);
    if keyclick
      then
        click;
  until done;
  get_str := current_char;               {Return the terminator}
  in_str := in_string;
end;

{17**************************************************************************}

function get_num  (                   {* This routine gets number from user *}
                   var value     : real;   {* Current Value and Returned Value   *}
                   decimals  : integer;{* Number of Decimal Places           *}
                   min_value : real;   {* Minimum Value                      *}
                   max_value : real;   {* Maximum Value                      *}
                   x         : byte;   {* Column                             *}
                   y         : byte    {* Row                                *}
)         : char;   {* Terminator                         *}
{*                                    *}
{* This routine does basically the    *}
{* thing as Get_Str only for numbers  *}
{* There are more options however.    *}
{* Basically Min and Max Value allow  *}
{* to specify the range of acceptable *}
{* values and DECIMALS allows you to  *}
{* specify the number of decimal      *}
{* places desired                     *}
{**************************************}

var
  i1,i2  : integer;
  s1     : long_string;
  s2     : long_string;
  s3     : long_string;
  inchar : char;

begin
  str(value:1:decimals,s1);       {Convert to a string}
  str(max_value:1:decimals,s3);   {find out how long a string max val is}

  repeat                 {Main Loop}
    s2 := '';

    valid_set := numbers;
    inchar := get_str(s1,length(s3),x,y,false); {Get_Str does the }
{work}
    for i2 := 1 to length(s1) do     {Strip out non digits}
      if s1[i2] in (numbers - [','])
        then
          s2 := s2 + s1[i2];

    val(s2,value,i1);                 {Find out its value}

  until (value >= min_value) and (value <= max_value) and (i1 = 0); {do it }
{until its right}

  gotoxy(x,y);

  write_neatly(output,value,length(s3),decimals); {print the result}
  valid_set := allchars;

  get_num := inchar;  {Assign the terminator}

end;

{18**************************************************************************}

procedure frame(                      {* Frame the section of screen within *}
                upperleftx,           {* these bounds                       *}
                upperlefty,           {**************************************}
                lowerrightx,
                lowerrighty: integer);

var
  i: integer;

begin
  gotoxy(upperleftx,upperlefty);
  write(chr(218));
  gotoxy(upperleftx,lowerrighty);
  write(chr(192));
  gotoxy(lowerrightx,upperlefty);
  write(chr(191));
  gotoxy(lowerrightx,lowerrighty);
  write(chr(217));
  for i := upperleftx + 1 to lowerrightx - 1 do
    begin
      gotoxy(i,upperlefty);
      write(chr(196));
      gotoxy(i,lowerrighty);
      write(chr(196));
    end;
  for i := upperlefty + 1 to lowerrighty - 1 do
    begin
      gotoxy(upperleftx,i);
      write(chr(179));
      gotoxy(lowerrightx,i);
      write(chr(179));
    end;
end;  { Frame }

{19***************************************************************************}

procedure unframe(                      {* This routine does the opposite of *}
                  upperleftx,           {* frame                             *}
                  upperlefty,           {*************************************}
                  lowerrightx,
                  lowerrighty: integer);

var
  i: integer;
begin
  gotoxy(upperleftx, upperlefty);
  write(' ');

  for i:=upperleftx+1 to lowerrightx-1 do
    write(' ');

  write(' ');

  for i:=upperlefty+1 to lowerrighty-1 do
    begin
      gotoxy(upperleftx , i);
      write(' ');
      gotoxy(lowerrightx, i);
      write(' ');
    end;

  gotoxy(upperleftx, lowerrighty);
  write(' ');

  for i:=upperleftx+1 to lowerrightx-1 do
    write(' ');

  write(' ');
end;  {UnFrame }

{20**************************************************************************}

function menu (                               {* Display a Menu             *}
               item_list  : menu_selections; {* List of Options on Menu    *}
{* Last Item must be Null     *}
{* String for proper operation*}
{* No more than 30 items per  *}
               menu_x     : integer;         {* X Location of Menu         *}
               menu_y     : integer;         {* Y Location of Menu         *}
               menu_title : menu_item;       {* Title of Menu              *}
               title_x    : integer;         {* X Location of Title        *}
               title_y    : integer;         {* Y Location of Title        *}
               default    : integer          {* Default Selection          *}
)            : integer;         {* Return the index of the    *}
{* item selected by the user  *}
{*                            *}
{***********************************************                            *
* This Routine Displays a Menu on the screen at the location specified by   *
* Menu_X and Menu_Y.  The Menu Title is displayed in Reverse Video at the   *
* Location specified by Title_X and Title_Y.  The User selects an item from *
* the menu by using <CTRL>-E to move a reverse video cursor bar up and      *
* <CTRL>-X to move it down.  After the cursor is on the item desired by the *
* user, he must press return.  At this point the routine returns the item   *
* number of the selection.                                                  *
*****************************************************************************}

const
  cr = #13;
  up = #5;
  dn = #24;

var
  first_shown : integer;
  last_shown  : integer;
  inchar : char;
  menu_pointer : 1..15;
  menu_length : 1..15;
  last : integer;
  last_y : integer;
  width : integer;
  len   : integer;
  maxlen : integer;
  x1,x2,y1,y2 : integer;
  i,j,k   : integer;
  instr : long_string;
  ls    : integer;

begin {Menu}

  instr := '';

  width := lower_right_x - upper_left_x + 1;   {Calculate Window Size}
  len   := lower_right_y - upper_left_y + 1;
  maxlen  := len + 2;

  if width > 70
    then begin
           gotoxy(1,1);
           color(12,back_ground_color);
           writeln('IMEX -  (800) 222 - 9188');
           color(15,back_ground_color2);
           write(center(width,menu_title));
      end
    else begin
           gotoxy(title_x,title_y);
           color(15,back_ground_color2);
           write(menu_title);
      end;

  color(15,back_ground_color);

  if width > 38
    then        {If there is enough room, write out instructions}
      begin                   {otherwise, they is out a luck}
        maxlen := maxlen - 3;
        frame(1,len-3,width-1,len);
        gotoxy((width div 2) - 6,len-3);
        write(#17);
        rvson;
        write('Instructions');
        rvsoff;
        write(#16);
        textcolor(15);
        gotoxy(2,len-2);
        write(center(width-3,'Use '+#24+' and '+#25+' to Highlight a Selection'));
        gotoxy(2,len-1);
        write(center(width-3,' And '+#17+'─┘ to make the Selection'));
      end;

  inchar := ' ';               {Initialize variables}
  menu_pointer := 1;

{Display the actual menu selections and determine how many selections
are available}

  maxlen := maxlen - menu_y;

  menu_length := 1;
  while (item_list[menu_length + 1] <> '*') and
        (item_list[menu_length + 1] <> '' ) do
    menu_length := menu_length + 1;

  for i := 1 to menu_length do
    if length(item_list[i]) > 40
      then
        item_list[i] := copy(item_list[i],1,40);

  if maxlen > ((menu_length) * 2)
    then
      ls := 2
    else
      ls := 1;

  first_shown := 1;
  last_shown := menu_length;
  while (last_shown * ls + menu_y) > maxlen do
    last_shown := last_shown - 1;

  menu_pointer := default;
  if menu_pointer > menu_length
    then
      menu_pointer := last_shown;

  i := 0;
  for j := first_shown to last_shown do
    begin
      gotoxy(menu_x, menu_y + (i * ls));
      write(item_list[j]:length(item_list[j]));
      i := i + 1;
      clreol;
    end;

  last_y := wherey;
  last := first_shown;
  if last = default
    then
      last := last_shown;

  while inchar <> cr do          {Main loop}

    begin

      if (menu_pointer < first_shown) or (menu_pointer > last_shown)
        then
          begin
            while  menu_pointer < first_shown do
              begin
                first_shown := first_shown - 1;
                if first_shown < 1
                  then
                    first_shown := 1;
                last_shown := last_shown - 1;
                if last_shown < 1
                  then
                    last_shown := 1;
              end;

            while menu_pointer > last_shown do
              begin
                first_shown := first_shown + 1;
                last_shown := last_shown + 1;
              end;

            if last_shown > menu_length
              then
                last_shown := menu_length;

            i := 0;
            for j := first_shown to last_shown do
              begin
                if j = menu_pointer
                  then
                    rvson;
                gotoxy(menu_x, menu_y + (i * ls));
                write(item_list[j]:length(item_list[j]));
                if (item_list[j][length(item_list[j])] = ']') and (menu_pointer = j)
                  then
                    begin
                      write(^h,^h,'X]');
                      last_y := wherey;
                    end;
                i := i + 1;
                if j = menu_pointer
                  then
                    rvsoff;
                clreol;
              end;
          end
        else
          begin
            rvsoff;
            if last = (menu_length)
              then
                last_y := (last_shown - first_shown) * ls + menu_y;
            if last = 1
              then
                last_y := menu_y;
            gotoxy(menu_x,last_y);
            write(item_list[last]);
            gotoxy(menu_x,menu_y + (menu_pointer - first_shown) * ls);
            rvson;
            last_y := wherey;
            write(item_list[menu_pointer]:length(item_list[menu_pointer]));
            if item_list[menu_pointer][length(item_list[menu_pointer])] = ']'
              then
                write(^h,^h,'X]');
            rvsoff;
            clreol;
          end;

      read(kbd,inchar);    {get a character from the user}
      click;
      if (inchar = ^[) and not keypressed
        then
          begin
            menu := default;
            exit;
          end;

      last := menu_pointer;

      if not (inchar in [^[,up,dn,cr])
        then

          begin

            if inchar = #127
              then
                instr := ''
              else

                if inchar = ^h
                  then
                    delete(instr,length(instr),1)
                  else
                    instr := instr + inchar;

            j := 0;
            k := 0;

            for i := 1 to menu_length do

              if lower(instr) = lower(copy(item_list[i],1,length(instr)))
                then

                  begin
                    inc(j);

                    if k = 0
                      then
                        k := i;

                  end;

            if k <> 0
              then
                menu_pointer := k;

            if (j = 1) or (j = 0)
              then
                instr := '';

          end;

      if (inchar = ^[) and keypressed
        then   {get the escape code}
          read(kbd, inchar);

      if inchar = ';'
        then
          begin
            x1 := upper_left_x;
            y1 := upper_left_y;
            x2 := lower_right_x;
            y2 := lower_right_y;
            help;
            window(x1,y1,x2,y2);
          end;

      if (inchar = up) or (inchar = 'H')
        then
          begin                                    {They hit up arrow}
            menu_pointer := menu_pointer - 1;
            if menu_pointer < 1
              then
                menu_pointer := (menu_length);
            instr := '';
          end;  {If}

      if (inchar = dn) or (inchar = 'P')
        then
          begin                                    {They hit down arrow}
            menu_pointer := menu_pointer + 1;
            if menu_pointer > menu_length
              then
                menu_pointer := 1;
            instr := '';
          end;  {If}

    end; {While}

  beep(440);                                {They made a selection, beep once}
  menu := menu_pointer;                     {to confirm}

end; {Menu}

{22**************************************************************************}

procedure window_frame(x1,y1,             {* Create, frame and title a      *}
                       x2,y2 : integer;   {* window                         *}
                       title : menu_item);{**********************************}

var
  center : integer;

begin
  window(1,1,80,25);
  frame(x1 - 1, y1 - 1,
        x2 + 1, y2 + 1);
  center := ((x2 - x1) div 2) + x1;
  gotoxy(center - (length(title) div 2)-1,y1-1);
  write(#17);
  rvson;
  write(title);
  rvsoff;
  write(#16);
  window(x1,y1,x2,y2);
  clear_window;
end;

{48**************************************************************************}

type
  typelist = (ustr,lstr,ulstr,rnum,inum,yn,dte,phne,tme);
{ustr               upper case string
lstr               lower case string
ulstr              upper lower case string
rnum               real number
inum               integer
yn                 yes/no reply
dte                date
phne               phone number
tme                time}

function getform(   var value;
                 vtype   : typelist;
                 x,y,
                 dp,len  : integer;
                 lstrg   : long_string;
                 lx,ly   : integer
) : char;

var
  realval : real absolute value;
  intval  : integer absolute value;
  strval  : long_string absolute value;
  boolval : boolean absolute value;
  mval    : real;
  tint    : integer;
  tstr1,
  tstr    : long_string;
  valid   : boolean;
  tchar   : char;

begin
  gotoxy(lx,ly);
  highvideo;
  write(lstrg);
  case vtype of

    ustr  : begin
              getform := get_str(strval,len,x,y,true);
              valid_set := allchars;
            end;
    lstr  : begin
              valid_set := lowercase;
              getform := get_str(strval,len,x,y,false);
              strval := lower(strval);
              valid_set := allchars;
            end;
    ulstr : getform := get_str(strval,len,x,y,false);
    rnum  : begin
              valid_set := numbers;
              val(replicate(len - dp - 1,'9'),mval,tint);
              getform := get_num(realval,dp,0,mval,x,y);
              valid_set := allchars;
            end;
    inum  : begin
              valid_set := numbers;
              getform := get_num(mval,0,-32767,maxint,x,y);
              intval := trunc(mval);
              valid_set := allchars;
            end;
    yn    : begin
              valid_set := ['Y','N','y','n'];
              gotoxy(x,y);
              if boolval
                then
                  tstr := 'Y'
                else
                  tstr := 'N';
              repeat
                tchar := get_str(tstr,1,x,y,true);
              until tstr[1] in ['Y','N'];
              boolval := tstr = 'Y';
              getform := tchar;
              valid_set := allchars;
            end;
    dte   : begin
              valid := false;
              valid_set := digits;
              tstr := copy(strval,1,2);
              repeat
                getform := get_str(tstr,2,x,y,false);
                valid := ((tstr[1] = '1') and (tstr[2] in ['0'..'2'])) or
                         ((tstr[1] in [' ','0']) and (tstr[2] in ['0'..'9']));
              until valid;
              tstr1 := tstr + '/';
              gotoxy(x+2,y);
              write('/');
              valid := false;
              tstr := copy(strval,4,2);
              repeat
                getform := get_str(tstr,2,x+3,y,false);
                valid := ((tstr[1] = '3') and (tstr[2] in ['0'..'1'])) or
                         ((tstr[1] in [' ','0'..'2']) and (tstr[2] in ['0'..'9']));
              until valid;
              tstr1 := tstr1 + tstr + '/';
              gotoxy(x+5,y);
              write('/');
              valid := false;
              tstr := copy(strval,7,2);
              repeat
                getform := get_str(tstr,2,x+6,y,false);
                valid := (tstr[1] in ['8','9']) and (tstr[2] in ['0'..'9']);
              until valid;
              strval := tstr1 + tstr;
              valid_set := allchars;
            end;
    tme   : begin
              valid_set := digits;
              valid := false;
              tstr := copy(strval,1,2);
              repeat
                getform := get_str(tstr,2,x,y,false);
                valid := ((tstr[1] = '1') and (tstr[2] in ['0'..'2'])) or
                         ((tstr[1] in [' ','0']) and (tstr[2] in ['0'..'9']));
              until valid;
              tstr1 := tstr + ':';
              gotoxy(x+2,y);
              write('/');
              valid := false;
              tstr := copy(strval,4,2);
              repeat
                getform := get_str(tstr,2,x+3,y,false);
                valid := (tstr[1] in [' ','0'..'5']) and (tstr[2] in ['0'..'9']);
              until valid;
              tstr1 := tstr1 + tstr + ':';
              gotoxy(x+5,y);
              write('/');
              valid := false;
              tstr := copy(strval,7,2);
              repeat
                getform := get_str(tstr,2,x+6,y,false);
                valid := (tstr[1] in ['0'..'5']) and (tstr[2] in ['0'..'9']);
              until valid;
              strval := tstr1 + tstr;
              valid_set := allchars;
            end;
    phne  : begin
              valid_set := digits;
              valid := false;
              gotoxy(x,y);
              write('(');
              tstr := copy(strval,2,3);
              repeat
                getform := get_str(tstr,3,x+1,y,false);
                valid := tstr[2] in ['0','1'];
              until valid;
              tstr1 := '(' + tstr + ') ';
              gotoxy(x+4,y);
              write(') ');
              tstr := copy(strval,7,3);
              getform := get_str(tstr,3,x+6,y,false);
              tstr1 := tstr1 + tstr + '-';
              gotoxy(x+10,y);
              write('-');
              tstr := copy(strval,11,4);
              getform := get_str(tstr,4,x+10,y,false);
              tstr1 := tstr1 + tstr;
              strval := tstr1;
              valid_set := allchars;
            end;
  end;

  gotoxy(lx,ly);
  lowvideo;
  write(lstrg);
end;

{*********************************************************************}

const monthmask = $000f;
  daymask = $001f;
  minutemask = $003f;
  secondmask = $001f;

type  dtstr = string[8];

{49*******************************************************************}

function getdate : dtstr;

var
  allregs : register;
  month, day,
  year    : string[2];
  i       : integer;
  tstr    : dtstr;

begin
  allregs.ax := $2a * 256;
  msdos(allregs);
  str((allregs.dx div 256): 2,month);
  str((allregs.dx mod 256): 2,day);
  str((allregs.cx - 1900): 2,year);
  tstr := month + '/' + day + '/' + year;
  for i := 1 to 8 do
    if tstr[i] = ' '
      then
        tstr[i] := '0';
  getdate := tstr;
end;  {getdate}

{50*******************************************************************}

function gettime : dtstr;

var
  allregs : register;
  hour, minute,
  second  : string[2];
  i       : integer;
  tstr    : dtstr;

begin
  allregs.ax := $2c * 256;
  msdos(allregs);
  str((allregs.cx div 256): 2,hour);
  str((allregs.cx mod 256): 2,minute);
  str((allregs.dx div 256): 2,second);
  tstr := hour + ':' + minute + ':' + second;
  for i := 1 to 8 do
    if tstr[i] = ' '
      then
        tstr[i] := '0';
  gettime := tstr;
end;  {gettime}

{51*******************************************************************}

procedure push_window(x1,y1,x2,y2 : integer);

var
  temp : video_ptr;
  i,j,k  : integer;

begin
  if screen = nil
    then
      screen := ptr($b000,0);
  new(temp);
  temp^.x1 := x1;
  temp^.y1 := y1;
  temp^.x2 := x2;
  temp^.y2 := y2;
  getmem(temp^.screen_store,((x2 - x1 + 1) * (y2 - y1 + 1)) * 2);
  temp^.next_screen := screen_stack;
  k := 1;
  for i := y1 to y2 do
    for j := x1 to x2 do
      begin
        temp^.screen_store^[k] := screen^[i][j];
        inc(k);
      end;
  screen_stack := temp;
end;

{*************************}